home *** CD-ROM | disk | FTP | other *** search
/ isnet Internet / Isnet Internet CD.iso / prog / hiz / 09 / 09.exe / adynware.exe / perl / lib / Cwd.pm < prev    next >
Encoding:
Perl POD Document  |  1999-12-28  |  7.5 KB  |  348 lines
  1. package Cwd;
  2. require 5.000;
  3.  
  4. =head1 NAME
  5.  
  6. getcwd - get pathname of current working directory
  7.  
  8. =head1 SYNOPSIS
  9.  
  10.     use Cwd;
  11.     $dir = cwd;
  12.  
  13.     use Cwd;
  14.     $dir = getcwd;
  15.  
  16.     use Cwd;
  17.     $dir = fastgetcwd;
  18.  
  19.     use Cwd 'chdir';
  20.     chdir "/tmp";
  21.     print $ENV{'PWD'};
  22.  
  23. =head1 DESCRIPTION
  24.  
  25. The getcwd() function re-implements the getcwd(3) (or getwd(3)) functions
  26. in Perl.
  27.  
  28. The fastcwd() function looks the same as getcwd(), but runs faster.
  29. It's also more dangerous because you might conceivably chdir() out of a
  30. directory that you can't chdir() back into.
  31.  
  32. The cwd() function looks the same as getcwd and fastgetcwd but is
  33. implemented using the most natural and safe form for the current
  34. architecture. For most systems it is identical to `pwd` (but without
  35. the trailing line terminator). It is recommended that cwd (or another
  36. *cwd() function) is used in I<all> code to ensure portability.
  37.  
  38. If you ask to override your chdir() built-in function, then your PWD
  39. environment variable will be kept up to date.  (See
  40. L<perlsub/Overriding Builtin Functions>.) Note that it will only be
  41. kept up to date if all packages which use chdir import it from Cwd.
  42.  
  43. =cut
  44.  
  45.  
  46. use Carp;
  47.  
  48. $VERSION = '2.00';
  49.  
  50. require Exporter;
  51. @ISA = qw(Exporter);
  52. @EXPORT = qw(cwd getcwd fastcwd fastgetcwd);
  53. @EXPORT_OK = qw(chdir abs_path fast_abs_path);
  54.  
  55.  
  56.  
  57. sub _backtick_pwd {
  58.     my $cwd;
  59.     chop($cwd = `pwd`);
  60.     $cwd;
  61. }
  62.  
  63.  
  64. *cwd = \&_backtick_pwd unless defined &cwd;
  65.  
  66.  
  67.  
  68. sub getcwd
  69. {
  70.     my($dotdots, $cwd, @pst, @cst, $dir, @tst);
  71.  
  72.     unless (@cst = stat('.'))
  73.     {
  74.     warn "stat(.): $!";
  75.     return '';
  76.     }
  77.     $cwd = '';
  78.     $dotdots = '';
  79.     do
  80.     {
  81.     $dotdots .= '/' if $dotdots;
  82.     $dotdots .= '..';
  83.     @pst = @cst;
  84.     unless (opendir(PARENT, $dotdots))
  85.     {
  86.         warn "opendir($dotdots): $!";
  87.         return '';
  88.     }
  89.     unless (@cst = stat($dotdots))
  90.     {
  91.         warn "stat($dotdots): $!";
  92.         closedir(PARENT);
  93.         return '';
  94.     }
  95.     if ($pst[0] == $cst[0] && $pst[1] == $cst[1])
  96.     {
  97.         $dir = '';
  98.     }
  99.     else
  100.     {
  101.         do
  102.         {
  103.         unless (defined ($dir = readdir(PARENT)))
  104.             {
  105.             warn "readdir($dotdots): $!";
  106.             closedir(PARENT);
  107.             return '';
  108.         }
  109.         unless (@tst = lstat("$dotdots/$dir"))
  110.         {
  111.         }
  112.         }
  113.         while ($dir eq '.' || $dir eq '..' || $tst[0] != $pst[0] ||
  114.            $tst[1] != $pst[1]);
  115.     }
  116.     $cwd = "$dir/$cwd";
  117.     closedir(PARENT);
  118.     } while ($dir);
  119.     chop($cwd) unless $cwd eq '/'; # drop the trailing /
  120.     $cwd;
  121. }
  122.  
  123.  
  124.  
  125.  
  126. sub fastcwd {
  127.     my($odev, $oino, $cdev, $cino, $tdev, $tino);
  128.     my(@path, $path);
  129.     local(*DIR);
  130.  
  131.     ($cdev, $cino) = stat('.');
  132.     for (;;) {
  133.     my $direntry;
  134.     ($odev, $oino) = ($cdev, $cino);
  135.     chdir('..');
  136.     ($cdev, $cino) = stat('.');
  137.     last if $odev == $cdev && $oino == $cino;
  138.     opendir(DIR, '.');
  139.     for (;;) {
  140.         $direntry = readdir(DIR);
  141.         next if $direntry eq '.';
  142.         next if $direntry eq '..';
  143.  
  144.         last unless defined $direntry;
  145.         ($tdev, $tino) = lstat($direntry);
  146.         last unless $tdev != $odev || $tino != $oino;
  147.     }
  148.     closedir(DIR);
  149.     unshift(@path, $direntry);
  150.     }
  151.     chdir($path = '/' . join('/', @path));
  152.     $path;
  153. }
  154.  
  155.  
  156.  
  157. my $chdir_init = 0;
  158.  
  159. sub chdir_init {
  160.     if ($ENV{'PWD'} and $^O ne 'os2' and $^O ne 'msdos') {
  161.     my($dd,$di) = stat('.');
  162.     my($pd,$pi) = stat($ENV{'PWD'});
  163.     if (!defined $dd or !defined $pd or $di != $pi or $dd != $pd) {
  164.         $ENV{'PWD'} = cwd();
  165.     }
  166.     }
  167.     else {
  168.     $ENV{'PWD'} = cwd();
  169.     }
  170.     if ($ENV{'PWD'} =~ m|(/[^/]+(/[^/]+/[^/]+))(.*)|) {
  171.     my($pd,$pi) = stat($2);
  172.     my($dd,$di) = stat($1);
  173.     if (defined $pd and defined $dd and $di == $pi and $dd == $pd) {
  174.         $ENV{'PWD'}="$2$3";
  175.     }
  176.     }
  177.     $chdir_init = 1;
  178. }
  179.  
  180. sub chdir {
  181.     my $newdir = shift || '';    # allow for no arg (chdir to HOME dir)
  182.     $newdir =~ s|///*|/|g;
  183.     chdir_init() unless $chdir_init;
  184.     return 0 unless CORE::chdir $newdir;
  185.     if ($^O eq 'VMS') { return $ENV{'PWD'} = $ENV{'DEFAULT'} }
  186.  
  187.     if ($newdir =~ m#^/#) {
  188.     $ENV{'PWD'} = $newdir;
  189.     } else {
  190.     my @curdir = split(m#/#,$ENV{'PWD'});
  191.     @curdir = ('') unless @curdir;
  192.     my $component;
  193.     foreach $component (split(m#/#, $newdir)) {
  194.         next if $component eq '.';
  195.         pop(@curdir),next if $component eq '..';
  196.         push(@curdir,$component);
  197.     }
  198.     $ENV{'PWD'} = join('/',@curdir) || '/';
  199.     }
  200.     1;
  201. }
  202.  
  203.  
  204. sub abs_path
  205. {
  206.     my $start = shift || '.';
  207.     my($dotdots, $cwd, @pst, @cst, $dir, @tst);
  208.  
  209.     unless (@cst = stat( $start ))
  210.     {
  211.     carp "stat($start): $!";
  212.     return '';
  213.     }
  214.     $cwd = '';
  215.     $dotdots = $start;
  216.     do
  217.     {
  218.     $dotdots .= '/..';
  219.     @pst = @cst;
  220.     unless (opendir(PARENT, $dotdots))
  221.     {
  222.         carp "opendir($dotdots): $!";
  223.         return '';
  224.     }
  225.     unless (@cst = stat($dotdots))
  226.     {
  227.         carp "stat($dotdots): $!";
  228.         closedir(PARENT);
  229.         return '';
  230.     }
  231.     if ($pst[0] == $cst[0] && $pst[1] == $cst[1])
  232.     {
  233.         $dir = '';
  234.     }
  235.     else
  236.     {
  237.         do
  238.         {
  239.         unless (defined ($dir = readdir(PARENT)))
  240.             {
  241.             carp "readdir($dotdots): $!";
  242.             closedir(PARENT);
  243.             return '';
  244.         }
  245.         $tst[0] = $pst[0]+1 unless (@tst = lstat("$dotdots/$dir"))
  246.         }
  247.         while ($dir eq '.' || $dir eq '..' || $tst[0] != $pst[0] ||
  248.            $tst[1] != $pst[1]);
  249.     }
  250.     $cwd = "$dir/$cwd";
  251.     closedir(PARENT);
  252.     } while ($dir);
  253.     chop($cwd); # drop the trailing /
  254.     $cwd;
  255. }
  256.  
  257. sub fast_abs_path {
  258.     my $cwd = getcwd();
  259.     my $path = shift || '.';
  260.     chdir($path) || croak "Cannot chdir to $path:$!";
  261.     my $realpath = getcwd();
  262.     chdir($cwd)  || croak "Cannot chdir back to $cwd:$!";
  263.     $realpath;
  264. }
  265.  
  266.  
  267.  
  268.  
  269. sub _vms_cwd {
  270.     return $ENV{'DEFAULT'};
  271. }
  272.  
  273. sub _vms_abs_path {
  274.     return $ENV{'DEFAULT'} unless @_;
  275.     my $path = VMS::Filespec::pathify($_[0]);
  276.     croak("Invalid path name $_[0]") unless defined $path;
  277.     return VMS::Filespec::rmsexpand($path);
  278. }
  279.  
  280. sub _os2_cwd {
  281.     $ENV{'PWD'} = `cmd /c cd`;
  282.     chop $ENV{'PWD'};
  283.     $ENV{'PWD'} =~ s:\\:/:g ;
  284.     return $ENV{'PWD'};
  285. }
  286.  
  287. sub _win32_cwd {
  288.     $ENV{'PWD'} = Win32::GetCurrentDirectory();
  289.     $ENV{'PWD'} =~ s:\\:/:g ;
  290.     return $ENV{'PWD'};
  291. }
  292.  
  293. *_NT_cwd = \&_win32_cwd if (!defined &_NT_cwd && 
  294.                             defined &Win32::GetCurrentDirectory);
  295.  
  296. *_NT_cwd = \&_os2_cwd unless defined &_NT_cwd;
  297.  
  298. sub _msdos_cwd {
  299.     $ENV{'PWD'} = `command /c cd`;
  300.     chop $ENV{'PWD'};
  301.     $ENV{'PWD'} =~ s:\\:/:g ;
  302.     return $ENV{'PWD'};
  303. }
  304.  
  305. {
  306.     local $^W = 0;    # assignments trigger 'subroutine redefined' warning
  307.  
  308.     if ($^O eq 'VMS') {
  309.         *cwd        = \&_vms_cwd;
  310.         *getcwd        = \&_vms_cwd;
  311.         *fastcwd    = \&_vms_cwd;
  312.         *fastgetcwd    = \&_vms_cwd;
  313.         *abs_path    = \&_vms_abs_path;
  314.         *fast_abs_path    = \&_vms_abs_path;
  315.     }
  316.     elsif ($^O eq 'NT' or $^O eq 'MSWin32') {
  317.         *cwd        = \&_NT_cwd;
  318.         *getcwd        = \&_NT_cwd;
  319.         *fastcwd    = \&_NT_cwd;
  320.         *fastgetcwd    = \&_NT_cwd;
  321.         *abs_path    = \&fast_abs_path;
  322.     }
  323.     elsif ($^O eq 'os2') {
  324.         *cwd        = defined &sys_cwd ? \&sys_cwd : \&_os2_cwd;
  325.         *getcwd        = \&cwd;
  326.         *fastgetcwd    = \&cwd;
  327.         *fastcwd    = \&cwd;
  328.         *abs_path    = \&fast_abs_path;
  329.     }
  330.     elsif ($^O eq 'msdos') {
  331.         *cwd        = \&_msdos_cwd;
  332.         *getcwd        = \&_msdos_cwd;
  333.         *fastgetcwd    = \&_msdos_cwd;
  334.         *fastcwd    = \&_msdos_cwd;
  335.         *abs_path    = \&fast_abs_path;
  336.     }
  337. }
  338.  
  339.  
  340. 1;
  341.  
  342. __END__
  343. BEGIN { import Cwd qw(:DEFAULT chdir); }
  344. print join("\n", cwd, getcwd, fastcwd, "");
  345. chdir('..');
  346. print join("\n", cwd, getcwd, fastcwd, "");
  347. print "$ENV{PWD}\n";
  348.